{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  ContML.Parser
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Types.
--
--------------------------------------------------------------------------------

module ContML.Parser
  (

    MLParser
  , parseFromFile
  , parseML
    
  ) where


import ContML.Syntax
import ContML.Types
import ContML.VarId


import Text.Parsec
-- import Text.Parsec.Expr
import Text.Parsec.String hiding ( parseFromFile )
import Text.Parsec.Language ( emptyDef )
import Text.Parsec.Token ( GenLanguageDef(..) )
import qualified Text.Parsec.Token as P

import Control.Applicative hiding ( (<|>), many )

type MLParser a = GenParser Char () a


factor :: MLParser a -> MLParser b 
       -> (a -> c) -> (a -> b -> c) 
       -> MLParser c
factor p q fk sk = 
    (\a opt -> maybe (fk a) (sk a) opt) <$> p <*> optionMaybe q



  
parseFromFile :: FilePath -> IO (Either String Expr)
parseFromFile path = parseML <$> readFile path 


parseML :: String -> Either String Expr
parseML ss = 
  case runParser expression () "" ss of
    Left err    -> Left (show err)
    Right a     -> Right a

expression :: MLParser Expr
expression = 
        letExpression
    <|> funExpression
    <|> untupleExpression
    <|> tagExpression
    <|> letfunExpression
    <|> caseExpression
    <|> raiseExpression
    <|> tryExpression
    <|> applyExpression
    <?> "expression"

letExpression :: MLParser Expr
letExpression = 
    LetVal <$> (try (reserved "let" *> reserved "val")  *> varid) 
           <*> (reservedOp "="   *> expression)
           <*> (reserved   "in"  *> expression) 


funExpression :: MLParser Expr
funExpression = 
    Fun <$> (reserved   "fn"  *> varid) 
        <*> (reservedOp "=>"  *> expression)


untupleExpression :: MLParser Expr
untupleExpression = 
    Unpair <$> (char '#' *> int) <*> expression

tagExpression :: MLParser Expr
tagExpression = 
    Tag <$> (string "in" *> int) <*> expression

letfunExpression :: MLParser Expr
letfunExpression = 
    LetFun <$> (try (reserved "let" *> reserved "fun") *> many1 def)
           <*> (reserved "in"  *> expression <* reserved "end")


caseExpression :: MLParser Expr
caseExpression = 
    Case <$> (reserved   "case" *> expression <* reserved "of") 
         <*> (reserved   "in1"  *> varid) 
         <*> (reservedOp "=>"   *> expression)
         <*> (reservedOp "|"    *> reserved "in2" *> varid)
         <*> (reservedOp "=>"   *> expression)

raiseExpression :: MLParser Expr
raiseExpression =
    Raise <$> (reserved "raise" *> expression)


tryExpression :: MLParser Expr
tryExpression = 
    Handle <$> (reserved   "try"    *> expression) 
           <*> (reserved   "handle" *> varid)  
           <*> (reservedOp "=>"     *> expression)

{-

infixExpression :: MLParser Expr
infixExpression = buildExpressionParser table applyExpression

-}

applyExpression :: MLParser Expr
applyExpression = mkApp <$> simpleExpression <*> many simpleExpression
  where
    mkApp l []     = l
    mkApp l (r:rs) = App l (mkApp r rs)


def :: MLParser Def
def = Def <$> varid <*> varid <*> (reservedOp "=" *> expression)

-- | For literals need try as Unit is empty parens.
--
simpleExpression :: MLParser Expr
simpleExpression = 
        try unitLiteral
    <|> parens (factor expression (comma *> expression) id Pair)
    <|> intLiteral
    <|> variable
    <?> "simple expression"


unitLiteral :: MLParser Expr
unitLiteral = (Unit <$ reservedOp "()") <?> "Unit literal"

intLiteral :: MLParser Expr
intLiteral = (Int <$> int) <?> "Int literal"

variable :: MLParser Expr
variable = (Var <$> varid) <?> "variable"


varid :: MLParser VarId
varid = (\x -> VarId x TyUnknown) <$> identifier

--------------------------------------------------------------------------------
-- Lexer

lexer :: P.TokenParser ()
lexer = P.makeTokenParser $ emptyDef
  { identStart        = letter
  , identLetter       = alphaNum <|> oneOf "_'"
  , caseSensitive     = True
  , commentStart      = "(*"
  , commentEnd        = "*)"
  , opStart           = opLetter emptyDef
  , opLetter          = oneOf "=>#|"  
  , reservedNames     = [ "fn"
                        , "in1", "in2" 
                        , "let", "val", "in", "end"
                        , "case", "of"
                        ]
                        
  , reservedOpNames   = [ "=>", "#", "=", "|", "()" ]
  }

identifier      :: MLParser  String
identifier      = P.identifier lexer

reservedOp      :: String -> MLParser ()
reservedOp      = P.reservedOp lexer


int             :: MLParser Int
int             = fromIntegral <$> P.integer lexer

reserved        :: String -> MLParser ()
reserved        = P.reserved lexer

parens          :: MLParser a -> MLParser a
parens          = P.parens lexer

comma           :: MLParser String
comma           = P.comma lexer



